Delphi Programmer's Power Pack/Delphi Volume 1.iso/e_to_l/isamexpt/dateedit.pas

Pascal/Delphi Source File | 1996-09-15 | 7.6 KB | 319 lines

unit Dateedit;

(*********************************************
TDateEdit -> TEdit

A date edit field with drop down calendar.

PROPERTIES:

Date - TDateTime that contains the date value of the control.

ValidDateColor - The color that "valid dates" will be rendered.

METHODS:

procedure AddValidDate - Adds a datetime value to a list of "valid dates" maintained by the
control.  These dates will be drawn in the color specified by ValidDateColor.

procedure ClearValidDates - Clears all "valid dates" from the list.

function DateInList - Checks if the specified date is in the list of "valid dates".

EVENTS:

OnDateChange - Triggered whenever the Date property is updated.
*********************************************)

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, Calpop, Buttons, IniFiles;

type

  PTDateTime = ^TDateTime;

  TDateButton = class( TBitBtn )
  private
  protected
     procedure Click; override;
  public
  published
  end;

  TDateEdit = class( TEdit )
  private
     hBitmap: HBitmap;
     FButton: TDateButton;
     FDate: TDateTime;
     FOnDateChange: TNotifyEvent;
     FValColor: TColor;
     lstDates: TList;
     sSep: string[1];
     sDateFmt: string[20];
     Token: integer;
     procedure SetToken;
     procedure SelectToken;
     procedure SetSeperators;
  protected
     nSep1, nSep2: integer;
     procedure WMSize( var Message: TWMSize ); message WM_SIZE;
     function GetDate: TDateTime;
     procedure SetDate( dtArg: TDateTime );
     procedure KeyPress( var Key: char ); override;
     procedure MouseUp( Button: TMouseButton; ShiftState: TShiftState; X, Y: integer ); override;
     procedure DoExit; override;
     procedure DoEnter; override;
  public
     constructor Create( AOwner: TComponent ); override;
     destructor Destroy; override;
     procedure CreateParams( var Params: TCreateParams ); override;
     property Date: TDateTime read GetDate write SetDate;
     function DateInList( dt: TDateTime ): boolean;
     procedure AddValidDate( dt: TDateTime );
     procedure ClearValidDates;
  published
     property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
     property ValidDateColor: TColor read FValColor write FValColor default clMaroon;
  end;

var
  frmCalendar: TfrmCalPop;

implementation

{$R DATEEDIT}

{--- TDateButton ---}
procedure TDateButton.Click;
var
  editParent: TDateEdit;
begin
  editParent := TDateEdit( Parent );
  frmCalendar := TfrmCalPop.Create( editParent );
  frmCalendar.ShowModal;
  frmCalendar.Free;
  inherited Click;
  EditParent.SetFocus;
  EditParent.DoEnter;
end;

{--- TDateEdit ---}

constructor TDateEdit.Create( AOwner: TComponent );
var
  ini: TIniFile;
begin
  inherited Create( AOwner );

{ Get international time seperator }
  ini := TIniFile.Create( 'WIN.INI' );
  sSep := ini.ReadString( 'intl', 'sDate', '.' );
  sDateFmt := ini.ReadString( 'intl', 'sShortDate', 'd.M.yyyy' );
  Token := 1;
  ini.Free;

  FDate := 0.0;
  FButton := TDateButton.Create( self );
  FButton.Visible := TRUE;
  FButton.Parent := self;
  FButton.TabStop:= False;
  FButton.Glyph.Handle := LoadBitmap( hInstance, 'CALPOPUP' );
  ControlStyle := ControlStyle - [csSetCaption];
  lstDates := TList.Create;
  FValColor := clBlue;
end;

procedure TDateEdit.CreateParams( var Params: TCreateParams );
begin
  inherited CreateParams( Params );
  Params.Style := Params.Style or WS_CLIPCHILDREN;
end;

destructor TDateEdit.Destroy;
begin
  FButton := nil;
  ClearValidDates;
  lstDates.Free;
  inherited Destroy;
end;

procedure TDateEdit.WMSize( var Message: TWMSize );
begin
  FButton.Height := Height;
  FButton.Width := Height;
  FButton.Left := Width - Height;
  FButton.Refresh;
  if FDate = 0.0 then
     Date := Now;
end;

function TDateEdit.GetDate: TDateTime;
begin
  GetDate := FDate;
end;

procedure TDateEdit.SetDate( dtArg: TDateTime );
var
    FormattedDate : String;
begin
  if FDate <> dtArg then
     begin
        FDate := dtArg;
        Modified := TRUE;
        if FDate = 0 then
           Text := ''
        else
           Text := FormatDateTime( sDateFmt, FDate );
        if Assigned( FOnDateChange ) then
           FOnDateChange( self );
     end;
end;

procedure TDateEdit.DoEnter;
begin
  inherited DoEnter;
  Token := 1;
  SetSeperators;
  SelectToken;
end;

procedure TDateEdit.DoExit;
begin
  inherited DoExit;
  try
     Date := StrToDate( Text );
  except
     Date := Now;
     SetFocus;
  end;
end;

(*********************************************
Is the supplied data in the date list?
*********************************************)
function TDateEdit.DateInList( dt: TDateTime ): boolean;
var
  pDate: PTDateTime;
  i: integer;
begin
  Result := FALSE;
  for i := 0 to lstDates.Count - 1 do
     begin
        pDate := lstDates[i];
        if pDate^ = dt then
           begin
              Result := TRUE;
              Break;
           end;
     end;
end;

(*********************************************
Maintain list of valid dates.
*********************************************)
procedure TDateEdit.AddValidDate( dt: TDateTime );
var
  pDate: PTDateTime;
begin
  New( pDate );
  pDate^ := dt;
  lstDates.Add( PDate );
end;

procedure TDateEdit.ClearValidDates;
var
  pDate: PTDateTime;
begin
  while lstDates.Count > 0 do
     begin
        pDate := lstDates[0];
        Dispose( pDate );
        lstDates.Delete( 0 );
     end;
end;

procedure TDateEdit.KeyPress( var Key: char );
begin
  if ( ( Key < '0' ) or ( Key > '9' ) ) and ( Key <> sSep[1] ) and ( Key <> #8 )
  and (Key <> #13) then
     Key := #0
  else if Key = sSep[1] then
     begin
        if Token < 3 then
           begin
              Inc( Token );
              SetSeperators;
              SelectToken;
              Key := #0;
           end
        else
           Key := #0;
     end
  else
     inherited KeyPress( Key );
end;

(*********************************************
Determine which token the user is on and highlight
the entire text of that token.
*********************************************)
procedure TDateEdit.MouseUp( Button: TMouseButton; ShiftState: TShiftState; X, Y: integer );
begin
  SetToken;
  SelectToken;
  inherited MouseUp( Button, ShiftState, X, Y );
end;

(*********************************************
Set the positions of the seperators in text.
*********************************************)
procedure TDateEdit.SetSeperators;
var
  i: integer;
begin
  nSep1 := Pos( sSep, Text );
  for i := nSep1 + 1 to Length( Text ) do
     if Text[i] = sSep then
        begin
           nSep2 := i;
           Break;
        end;
end;

(*********************************************
Determine which token the cursor is over;
*********************************************)
procedure TDateEdit.SetToken;
var
  nPos: integer;
begin
  nPos := SendMessage( Handle, cb_GetEditSel, 0, 0 ) div 65536;
  SetSeperators;
  if nPos <= nSep1 then
     Token := 1
  else if nPos <= nSep2 then
     Token := 2
  else
     Token := 3;
end;

(*********************************************
Select the token the cursor is on.
*********************************************)
procedure TDateEdit.SelectToken;
begin
  case Token of
     1:
        SendMessage( Handle, em_SetSel, 0, ( nSep1 - 1 ) * 65536 );
     2:
        SendMessage( Handle, em_SetSel, 0, ( nSep1 + ( nSep2 - 1 ) * 65536 ) );
     3:
        SendMessage( Handle, em_SetSel, 0, nSep2 + ( ( Length( Text ) ) * 65536 ) );
  end;
end;

end.